home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Moscow ML 1.42 / src / compiler / Rtvals.sml < prev    next >
Encoding:
Text File  |  1997-08-18  |  13.1 KB  |  420 lines  |  [TEXT/R*ch]
  1. (* Rtvals.sml *)
  2.  
  3. open List Misc Obj BasicIO Nonstdio Miscsys Memory Fnlib Config Mixture;
  4. open Const Smlexc Globals Units Types Symtable;
  5.  
  6. (* --- Run-time values --- *)
  7.  
  8. (* Encoding and decoding *)
  9.  
  10. fun decode_int (v : obj) = (magic_obj v : int);
  11.  
  12. fun decode_word (v : obj) = (magic_obj v : word);
  13.  
  14. fun decode_char (v : obj) = (magic_obj v : char);
  15.  
  16. fun decode_real (v : obj) = (magic_obj v : real);
  17.  
  18. fun decode_string (v : obj) = (magic_obj v : string);
  19.  
  20. (* Exceptions *)
  21.  
  22. type ExnName = QualifiedIdent ref;
  23.  
  24. fun remapExnName num_tag =
  25.   let val (qualid, stamp) = Symtable.get_exn_of_num num_tag
  26.   in Symtable.normalizeExnName qualid end
  27. ;
  28.  
  29. fun getExnNameArg (v : obj) (f : Const.QualifiedIdent -> obj option -> 'a) =
  30.     let val () = if not(is_block v) then fatalError "getExnNameArg 1"
  31.          else ()
  32.     val num_tag = obj_tag v
  33.     in
  34.     if num_tag = exnTag then
  35.         let val exnPrName = !(magic_obj (obj_field v 0) : ExnName) 
  36.         in 
  37.         case obj_size v of
  38.             1 => f exnPrName NONE
  39.           | 2 => f exnPrName (SOME (obj_field v 1))
  40.           | _ => fatalError "getExnNameArg 2"
  41.         end
  42.     else
  43.         let val exnPrName = remapExnName num_tag 
  44.         in 
  45.         case obj_size v of
  46.             0 => f exnPrName NONE
  47.           | 1 => f exnPrName (SOME (obj_field v 0))
  48.           | _ => f exnPrName (SOME v)
  49.         end
  50.     end;
  51.  
  52. fun decode_exn (v : obj) (c0 : QualifiedIdent -> unit) 
  53.                          (c1 : QualifiedIdent -> obj -> Type option -> unit) =
  54.     let fun prExn exnPrName NONE       = 
  55.         c0 exnPrName
  56.       | prExn exnPrName (SOME arg) = 
  57.         c1 exnPrName arg (Smlexc.exnArgType exnPrName)
  58.     in getExnNameArg v prExn end;
  59.  
  60. fun mkExnName {qual, id} = if qual = "Top" then id else qual ^ "." ^ id
  61.  
  62. fun getExnName (v : obj) = 
  63.     getExnNameArg v (fn exnPrName => fn _ => mkExnName exnPrName)
  64.  
  65. fun exnArgFmt {qual="General", id="SysErr"} (arg : obj) = 
  66.     decode_string (obj_field arg 0)
  67.   | exnArgFmt {qual="General", id="Io"} (arg : obj) = 
  68.     decode_string (obj_field arg 1) ^ " failed on `" (* function = idx 1 *)
  69.     ^ decode_string (obj_field arg 2) ^ "'; "        (* name     = idx 2 *)
  70.     ^ getExnMessage (obj_field arg 0)                 (* cause    = idx 0 *)
  71.   | exnArgFmt _                        (arg : obj) = 
  72.     if not(is_block arg) then "<poly>"
  73.     else let val tag = obj_tag arg
  74.      in 
  75.          if tag = stringTag then decode_string arg
  76.          else "<poly>"
  77.      end
  78. and getExnMessage (v : obj) =
  79.     let fun fmtExn exnPrName NONE       = mkExnName exnPrName
  80.       | fmtExn exnPrName (SOME arg) = 
  81.           mkExnName exnPrName ^ ": " ^ (exnArgFmt exnPrName arg)
  82.     in getExnNameArg v fmtExn end
  83.  
  84. (* Run-time environments *)
  85.  
  86. fun getGlobalVal (slot : int) =
  87.   Vector.sub(global_data, slot)
  88. ;
  89.  
  90. fun setGlobalVal (slot : int) (v : obj) =
  91.   let prim_val update_ : 'a Vector.vector -> int -> 'a -> unit
  92.                            = 3 "set_vect_item"
  93.   in update_ global_data slot v end
  94. ;
  95.  
  96. (* Block values *)
  97.  
  98. fun decode_block (v : obj) =
  99.   if not(is_block v) then
  100.     fatalError "block expected"
  101.   else
  102.     let val len = obj_size v
  103.         fun makeArgs i =
  104.               if i>= len then [] else obj_field v i :: makeArgs (i+1)
  105.     in (obj_tag v, makeArgs 0) end
  106. ;
  107.  
  108. fun decode_unit (v : obj) = ();
  109.  
  110. fun decode_pair (v : obj) = (magic_obj v : obj * obj);
  111.  
  112. fun decode_boolean (v : obj) = (magic_obj v : bool);
  113.  
  114. fun decode_list (v : obj) = (magic_obj v : obj list);
  115.  
  116. fun decode_vector (v : obj) = (magic_obj v : obj Vector.vector);
  117.  
  118. (* --- Value printing --- *)
  119.  
  120. fun prSeq lbr rbr printer sep ts vs =
  121.   let fun loop [] [] = ()
  122.         | loop [t] [v] = printer t v
  123.         | loop (t :: ts) (v :: vs) =
  124.             (printer t v; msgString sep; msgBreak(1, 1); loop ts vs)
  125.         | loop _ _ = fatalError "prSeq: length mismatch"
  126.   in
  127.     msgIBlock 0; msgString lbr;
  128.     loop ts vs;
  129.     msgString rbr; msgEBlock()
  130.   end
  131. ;
  132.  
  133. fun prInt (v: obj) =
  134.   let val n = decode_int v
  135.   in msgString (sml_string_of_int n) end
  136. ;
  137.  
  138. fun prWord (v: obj) =
  139.   let val n = decode_word v
  140.   in msgString (sml_hexstring_of_word n) end
  141. ;
  142.  
  143. fun prChar (v : obj) =
  144.   let val c = decode_char v
  145.   in msgString (sml_makestring_of_char c) end
  146. ;
  147.  
  148. fun prReal (v : obj) =
  149.   let val r = decode_real v
  150.   in msgString (sml_string_of_float r) end
  151. ;
  152.  
  153. fun prString (v : obj) =
  154.   let val s = decode_string v
  155.   in msgString (sml_makestring_of_string s) end
  156. ;
  157.  
  158. fun prLiteralConst (depth: int) (v: obj) =
  159.   if not(is_block v) then
  160.     prInt v
  161.   else if depth <= 0 then
  162.     msgString "#"
  163.   else
  164.     let val tag = obj_tag v
  165.         val len = obj_size v
  166.     in
  167.       if tag = realTag then
  168.         prReal v
  169.       else if tag = stringTag then
  170.         prString v
  171.       else
  172.         (msgString "(BLOCK "; msgInt tag;
  173.          for (fn i => (msgString " ";
  174.                        prLiteralConst (depth-1) (obj_field v i)))
  175.              0 (len-1);
  176.          msgString ")")
  177.     end
  178. ;
  179.  
  180. fun printLiteralConst (v: obj) =
  181.   prLiteralConst 10 v
  182. ;
  183.  
  184. fun prGeneric (v : obj) =
  185.   if not(is_block v) then
  186.     msgString "<poly>"
  187.   else
  188.     let val tag = obj_tag v in
  189.       if tag = realTag then prReal v
  190.       else if tag = stringTag then prString v
  191.       else msgString "<poly>"
  192.     end
  193. ;
  194.  
  195. val installedPrinters = ref([] : (TyName * (ppstream -> obj -> unit)) list);
  196.  
  197. fun findInstalledPrinter tyname =
  198.   let fun loop [] = NONE
  199.         | loop ((tyname', p) :: rest) =
  200.             if isEqTN tyname tyname' then (SOME p) else (loop rest)
  201.   in loop (!installedPrinters) end
  202. ;
  203.  
  204. val printDepth = ref 20;
  205. val printLength = ref 200;
  206.  
  207. fun prVal (depth: int) (prior: int) (tau: Type) (v: obj) =
  208.   let fun prP s = if prior > 0 then msgString s else ()
  209.       fun prD f = if depth <= 0 then msgString "#" else f()
  210.       val tau = normType tau
  211.   in
  212.     case tau of
  213.       VARt _ => (prP " "; prGeneric v)
  214.     | ARROWt _ => (prP " "; msgString "fn")
  215.     | RECt rt =>
  216.         let val {fields=fs, ...} = !rt
  217.             val (_, vs) = decode_block v
  218.         in
  219.           if isTupleRow fs then
  220.             (prD (fn() =>
  221.                prSeq "(" ")" (prTupleField (depth-1)) "," fs vs))
  222.           else
  223.             (prD (fn() =>
  224.                prSeq "{" "}" (prField (depth-1)) "," fs vs))
  225.         end
  226.     | CONt(ts, tyname) =>
  227.         (case #tnStr(! (#info tyname)) of
  228.            NILts => (
  229.              if      (isEqTN tyname tyname_int)    then (prP " "; prInt v)
  230.              else if (isEqTN tyname tyname_word)   then (prP " "; prWord v)
  231.              else if (isEqTN tyname tyname_word8)  then (prP " "; prWord v)
  232.              else if (isEqTN tyname tyname_char)   then (prP " "; prChar v)
  233.              else if (isEqTN tyname tyname_real)   then (prP " "; prReal v)
  234.              else if (isEqTN tyname tyname_string) then (prP " "; prString v)
  235.              else if (isEqTN tyname tyname_exn) then
  236.                decode_exn v
  237.                  (fn q =>
  238.                     (prP " "; printVQ q))
  239.                  (fn q => fn va => fn tyOpt =>
  240.                     (prP "(";
  241.                      printVQ q; msgString " ";
  242.              (case tyOpt of 
  243.               NONE    => prGeneric va
  244.             | SOME ty => prVal (depth-1) 1 ty va); 
  245.              prP ")"))
  246.              else if (isEqTN tyname tyname_ref) then
  247.                let val t = hd ts
  248.                    val x = obj_field v 0
  249.                in
  250.                  prD (fn() => (prP "("; printVQ (#qualid tyname);
  251.                                prVal (depth-1) 1 t x; prP ")"))
  252.                end
  253.              else if (isEqTN tyname tyname_vector) then
  254.                let val vs = decode_vector v in
  255.                  prD (fn() =>
  256.                    (prP " ";
  257.                     prVector (depth-1) (!printLength) (hd ts) vs))
  258.                end
  259.              else
  260.                (msgString "<"; msgString (#id (#qualid tyname));
  261.                 msgString ">"))
  262.          | DATATYPEts dt =>
  263.              (case findInstalledPrinter tyname of
  264.                 SOME printer => printer pp_out v
  265.               | NONE =>
  266.                   let val uname = #qual (#qualid tyname)
  267.                       val sign = if uname = currentUnitName()
  268.                                 then (!currentSig)
  269.                                 else findSig Location.nilLocation uname
  270.                       val CE = findConstructors sign dt
  271.                   in
  272.                     if null CE then
  273.                       (msgString "<"; msgString (#id (#qualid tyname));
  274.                        msgString ">")
  275.                     else if #conSpan(! (#info (hd CE))) = 1 andalso
  276.                             #conArity(! (#info (hd CE))) = 1
  277.                     then
  278.                       let val ci = hd CE
  279.                           val {qualid, info} = ci
  280.                           val {conArity, conIsGreedy, conType, ...} = !info
  281.                       in
  282.                         case specialization conType of
  283.                             ARROWt(a_t, r_t) =>
  284.                               (unify tau r_t;
  285.                                (prD (fn() =>
  286.                                   (prP "("; printVQ qualid;
  287.                                    prVal (depth-1) 1 a_t v;
  288.                                    prP ")"))))
  289.                           | _ => fatalError "prVal"
  290.                       end
  291.                     else
  292.                       let val i = obj_tag v
  293.                           val ci = nth(CE, i)
  294.                           val {qualid, info} = ci
  295.                           val {conArity, conIsGreedy, conType, ...} = !info
  296.                       in
  297.                         if (isEqTN tyname tyname_list) then
  298.                           (prD (fn() =>
  299.                              (prP " ";
  300.                               prList (depth-1) (!printLength)
  301.                                      (hd ts) (decode_list v))))
  302.                         else if conArity = 0 then
  303.                           (prD (fn() => (prP " "; printVQ qualid)))
  304.                         else
  305.                           case specialization conType of
  306.                               ARROWt(a_t, r_t) =>
  307.                                 (unify tau r_t;
  308.                                  (prD (fn() =>
  309.                                     (prP "("; printVQ qualid;
  310.                                      if conIsGreedy
  311.                                        then prVal (depth-1) 1 a_t v
  312.                                        else prVal (depth-1) 1 a_t (obj_field v 0);
  313.                                      prP ")"))))
  314.                             | _ => fatalError "prVal"
  315.                       end
  316.                   end)
  317.          | _ => fatalError "prVal")
  318.   end
  319.  
  320. and prField (depth: int) (lab, t) v =
  321.   (msgIBlock 0; printLab lab; msgString " ="; msgBreak(1, 2);
  322.    prVal depth 0 t v; msgEBlock())
  323.  
  324. and prTupleField (depth: int) (lab, t) v =
  325.   prVal depth 0 t v
  326.  
  327. and prList (depth: int) (len: int) tau v =
  328.   case v of
  329.       [] => msgString "[]"
  330.     | x :: xs =>
  331.         if len <= 0 then
  332.           msgString "[...]"
  333.         else
  334.           (msgIBlock 0; msgString "["; prVal depth 0 tau x;
  335.            prListTail depth (len-1) tau xs)
  336.  
  337. and prListTail (depth: int) (len: int) tau = fn
  338.     [] => (msgString "]"; msgEBlock())
  339.   | x :: xs =>
  340.       (msgString ","; msgBreak(1, 1);
  341.        if len <= 0 then
  342.          (msgString "...]"; msgEBlock())
  343.        else
  344.          (prVal depth 0 tau x; prListTail depth (len-1) tau xs))
  345.  
  346. and prVector (depth: int) (maxlen: int) tau v =
  347.   let val len = Vector.length v
  348.       fun loop count i =
  349.         if i = len then msgString "]"
  350.         else if count <= 0 then
  351.           (msgString ","; msgBreak(1, 2); msgString "...]")
  352.         else
  353.           (msgString ","; msgBreak(1, 2);
  354.            prVal depth 0 tau (Vector.sub(v, i));
  355.            loop (count-1) (i+1))
  356.   in
  357.     msgIBlock 0;
  358.     if len = 0 then msgString "#[]"
  359.     else if maxlen <= 0 then msgString "#[...]" else
  360.       (msgString "#["; prVal depth 0 tau (Vector.sub(v, 0));
  361.        loop (maxlen-1) 1);
  362.     msgEBlock()
  363.   end
  364. ;
  365.  
  366. fun printVal (scheme: TypeScheme) (v: obj) =
  367.   prVal (!printDepth) 0 (specialization scheme) v
  368. ;
  369.  
  370. fun evalPrint (sc : obj) (v : obj) =
  371.   (printVal (magic_obj sc : TypeScheme) v; msgFlush(); v)
  372. ;
  373.  
  374. fun evalInstallPP (sc : obj) (p : ppstream -> 'a -> unit) =
  375.   case normType(specialization (magic_obj sc : TypeScheme)) of
  376.       CONt([], tyname) =>
  377.         (case #tnStr(! (#info tyname)) of
  378.              DATATYPEts _ =>
  379.                installedPrinters :=
  380.                  (tyname, magic p : ppstream -> obj -> unit)
  381.                  :: !installedPrinters
  382.            | _ =>
  383.               raise Fail "installPP: pp's argument is not a datatype")
  384.     | CONt(_ :: _, tyname) =>
  385.         raise Fail "installPP: pp's argument type is not a nullary type constructor"
  386.     | _ =>
  387.         raise Fail "installPP: pp's argument type is not a type constructor"
  388. ;
  389.  
  390. (* === End of Primitives === *)
  391.  
  392. (* --- Handling global dynamic environment --- *)
  393.  
  394. fun loadGlobalDynEnv uname env =
  395. (
  396.   app (fn(id,_) =>
  397.              ignore (get_slot_for_defined_variable ({qual=uname, id=id}, 0)))
  398.     env;
  399.   if number_of_globals() >= Vector.length global_data then
  400.     realloc_global_data(number_of_globals())
  401.   else ();
  402.   app (fn(id,v) =>
  403.             let val slot = get_slot_for_variable ({qual=uname, id=id}, 0)
  404.             in setGlobalVal slot v end)
  405.           env
  406. );
  407.  
  408. fun resetGlobalDynEnv() =
  409. (
  410.   init_linker_tables();
  411.   if exnTag <> get_num_of_exn ({qual="General", id="(Exception)"}, 0)
  412.     then fatalError "resetGlobalDynEnv: Corrupted linker tables"
  413.   else () (* ;
  414.   app
  415.     (fn (id, ((q, stamp), arity)) =>
  416.        defineGlobalExceptionAlias ({qual="General", id=id}, (q, stamp)))
  417.     predefExceptions
  418. *)
  419. );
  420.